【无标题】 |
您所在的位置:网站首页 › excel vba复制工作表并重命名 › 【无标题】 |
VBA批量复制Excel工作表 工作时,经常需要制作多个工作表,手动操作费时费力,尝试VBA代码帮你快速完成工作。 1、复制单个工作表到指定工作表前面或后面,代码如下: Sheets("Sheet1").Copy After:=Sheets("Sheet2") '复制工作表Sheet1到Sheet2后面 Sheets("Sheet1").Copy Before:=Sheets("Sheet2") '复制工作表Sheet1到Sheet2前面 2、利用For循环,批量复制单张工作表到指定工作表前面或后面,代码如下: Dim i As Integer For i = 0 To 5 Sheets("Sheet1").Copy After:=Sheets("Sheet1") '复制工作表Sheet1到Sheet1后面 'Sheets("Sheet1").Copy Before:=Sheets("Sheet2") '复制工作表Sheet1到Sheet2前面 Next 结果是复制6次,效果如下图: 3、复制指定工作表,重命名后放在指定位置。复制工作表“Sheet1”,将复制后的工作表重命名为“Sheet2”并入在工作表最后,代码如下: Dim Sheets As Worksheet Dim MSheetName As String Dim YSheetName As String YSheetName = "Sheet1" '确定源工作表名称 MSheetName = "Sheet2" '确定目标工作表名称 Dim i As Integer '定义变量,判断是否有目标工作表名称时用 i = 0 Dim NewCopySheet As Worksheet 'Set NewCopySheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) For Each Sheets In Worksheets If Sheets.Name = MSheetName Then '先判断是否有目标工作表名称,若有提示重新修改目标工作表名字。 MsgBox ("已有工作表" & "请修改工作表名") i = 1 Exit For End If Next If i 1 Then '没有重复工作表名称,复制工作表并命名。前提应确保有源工作表“Sheet1” Worksheets(YSheetName).Copy After:=Worksheets(ThisWorkbook.Sheets.Count - 3) Set NewCopySheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) NewCopySheet.Name = MSheetName End If Application.DisplayAlerts = True 可以更改这行代码将目标工作表放在指定位置Set NewCopySheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count),放在倒数第二位Set NewCopySheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count-1),放倒数第三位Set NewCopySheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count-2),以此类推。 4、批量复制单张工作表并重命名。多次复制工作表“Sheet4”,将复制后的工作表重命名名称以数组列示Array("Sheet11", "Sheet12", "Sheet13", "Sheet14", "Sheet15"),复制后工作表放在最后,代码如下: Dim Sheets As Worksheet Dim MSheetName() As Variant Dim YSheetName As String Dim MSheetNameLength As Integer Dim i As Integer i = 0 MSheetName = Array("Sheet11", "Sheet12", "Sheet13", "Sheet14", "Sheet15") '确定复制后工作表重命名名称 YSheetName = "Sheet4" '确定源目标工作表名称 Dim j As Integer '定义变量,判断是否有目标工作表名称时用 Dim NewCopySheet As Worksheet MSheetNameLength = (UBound(MSheetName) - LBound(MSheetName) + 1) '计算目标工作表数组长度 For j = 0 To MSheetNameLength - 1 For Each Sheets In Worksheets If Sheets.Name = MSheetName(j) Then '先判断是否有目标工作表名称,若有提示重新修改目标工作表名字。 MsgBox ("已有工作表" & MSheetName(j) & ",请修改工作表名") i = 1 Exit Function End If Next Next If i 1 Then '没有重复工作表名称,复制工作表并命名。前提应确保有源工作表 For j = 0 To MSheetNameLength - 1 Worksheets(YSheetName).Copy After:=Worksheets(ThisWorkbook.Sheets.Count) Set NewCopySheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) NewCopySheet.Name = MSheetName(j) Next End If Application.DisplayAlerts = True 5、复制多张工作表并重命名。源工作表名称数组Array("Sheet11", "Sheet12", "Sheet13", "Sheet14", "Sheet15"),目标工作表名称数组Array("Sheet21", "Sheet22", "Sheet23", "Sheet24", "Sheet25"),复制源工作表名并重命名对应数组位置。代码如下: Dim Sheets As Worksheet Dim MSheetName() As Variant Dim YSheetName() As Variant Dim MSheetNameLength As Integer Dim i As Integer i = 0 MSheetName = Array("Sheet21", "Sheet22", "Sheet23", "Sheet24", "Sheet25") '确定源工作表名称 YSheetName = Array("Sheet1", "Sheet37", "Sheet38", "Sheet39", "Sheet40") '确定目标工作表名称 Dim j As Integer '定义变量,判断是否有目标工作表名称时用 Dim NewCopySheet As Worksheet MSheetNameLength = (UBound(MSheetName) - LBound(MSheetName) + 1) '计算目标工作表数组长度 For j = 0 To MSheetNameLength - 1 For Each Sheets In Worksheets If Sheets.Name = MSheetName(j) Then '先判断是否有目标工作表名称,若有提示重新修改目标工作表名字。 MsgBox ("已有工作表" & MSheetName(j) & ",请修改工作表名") i = 1 Exit Function End If Next Next
If i 1 Then '没有重复工作表名称,复制工作表并命名。前提应确保有源工作表 For j = 0 To MSheetNameLength - 1 Worksheets(YSheetName(j)).Copy After:=Worksheets(ThisWorkbook.Sheets.Count) Set NewCopySheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) NewCopySheet.Name = MSheetName(j) Next End If Application.DisplayAlerts = True 6、将源工作表和复制并重命名后的工作表名称列在Excel表格内,通过提取数据并复制重命名。源工作表名称和复制后重命名的工作表名称放在EXCEL表格A、B例中,遍历源工作表和目标工作表名称并分别放入数组,复制工作表的同时重命名对应的名称。代码如下: Dim Sheets As Worksheet Dim SheetActive As Worksheet Dim MSheetName() As Variant Dim YSheetName() As Variant Dim SheetYName As String Dim SheetMName As String Dim Numb As Integer Dim MSheetNameLength As Integer Dim SheetA As Integer Set SheetActive = ActiveSheet '确定活动单元格名称 SheetA = SheetActive.Cells(Rows.Count, 1).End(xlUp).Row Dim i, k As Integer i = 0 k = 0 ReDim YSheetName(SheetA) For Numb = 2 To SheetA '活动工作表第2行开始,遍历第一列工作表名称 SheetYName = SheetActive.Cells(Numb, 1).Value SheetMName = SheetActive.Cells(Numb, 2).Value '工作表名强制转换为字符串类型 If SheetYName "" And SheetMName "" Then '将源工作表和目标工作表名称放入数组,先计算数组长度 k = k + 1 End If Next
ReDim YSheetName(k) '重新定义源工作表和目标工作表数组长度 ReDim MSheetName(k) For Numb = 2 To SheetA '活动工作表第2行开始,遍历第一列工作表名称,为数组赋值 SheetYName = SheetActive.Cells(Numb, 1).Value SheetMName = SheetActive.Cells(Numb, 2).Value '工作表名强制转换为字符串类型 If SheetYName "" And SheetMName "" Then MSheetName(l) = SheetMName YSheetName(l) = SheetYName l = l + 1 '数组增加一个,l加1,最后会导致数组总数l比数组长度大1。 End If Next Dim j As Integer '定义变量,判断是否有目标工作表名称相同名称 Dim NewCopySheet As Worksheet MSheetNameLength = (UBound(MSheetName) - LBound(MSheetName) + 1) '计算目标工作表数组长度 For j = 0 To MSheetNameLength - 2 'l多1,多减去1 For Each Sheets In Worksheets If Sheets.Name = MSheetName(j) Then '先判断是否有目标工作表名称,若有提示重新修改目标工作表名字。 MsgBox ("已有工作表" & MSheetName(j) & ",请修改工作表名") i = 1 Exit Function End If Next Next If i 1 Then '没有重复工作表名称,复制工作表并命名。前提应确保有源工作表 For j = 0 To MSheetNameLength - 2 Worksheets(YSheetName(j)).Copy After:=Worksheets(ThisWorkbook.Sheets.Count) Set NewCopySheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) NewCopySheet.Name = MSheetName(j) Next End If Application.DisplayAlerts = True |
今日新闻 |
推荐新闻 |
CopyRight 2018-2019 办公设备维修网 版权所有 豫ICP备15022753号-3 |